home *** CD-ROM | disk | FTP | other *** search
/ Micromanía 93 / CDMM_93_2.ISO / Project Nomads / nomads_demo_eng.exe / INIT.TCL < prev    next >
Encoding:
Text File  |  2001-05-29  |  17.5 KB  |  590 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # RCS: @(#) $Id: init.tcl,v 1.2 2001/05/29 17:36:07 wfloh Exp $
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-1999 Scriptics Corporation.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. if {[info commands package] == ""} {
  17.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  18. }
  19. package require -exact Tcl 8.4
  20.  
  21. # Compute the auto path to use in this interpreter.
  22. # The values on the path come from several locations:
  23. #
  24. # The environment variable TCLLIBPATH
  25. #
  26. # tcl_library, which is the directory containing this init.tcl script.
  27. # tclInitScript.h searches around for the directory containing this
  28. # init.tcl and defines tcl_library to that location before sourcing it.
  29. #
  30. # The parent directory of tcl_library. Adding the parent
  31. # means that packages in peer directories will be found automatically.
  32. #
  33. # Also add the directory where the executable is located, plus ../lib
  34. # relative to that path.
  35. #
  36. # tcl_pkgPath, which is set by the platform-specific initialization routines
  37. #    On UNIX it is compiled in
  38. #       On Windows, it is not used
  39. #    On Macintosh it is "Tool Command Language" in the Extensions folder
  40.  
  41. if {![info exists auto_path]} {
  42.     if {[info exist env(TCLLIBPATH)]} {
  43.     set auto_path $env(TCLLIBPATH)
  44.     } else {
  45.     set auto_path ""
  46.     }
  47. }
  48. if {[string compare [info library] {}]} {
  49.     foreach __dir [list [info library] [file dirname [info library]]] {
  50.     if {[lsearch -exact $auto_path $__dir] < 0} {
  51.         lappend auto_path $__dir
  52.     }
  53.     }
  54. }
  55. set __dir [file join [file dirname [file dirname \
  56.     [info nameofexecutable]]] lib]
  57. if {[lsearch -exact $auto_path $__dir] < 0} {
  58.     lappend auto_path $__dir
  59. }
  60. if {[info exist tcl_pkgPath]} {
  61.     foreach __dir $tcl_pkgPath {
  62.     if {[lsearch -exact $auto_path $__dir] < 0} {
  63.         lappend auto_path $__dir
  64.     }
  65.     }
  66. }
  67. if {[info exists __dir]} {
  68.     unset __dir
  69. }
  70.   
  71. # Windows specific end of initialization
  72.  
  73. if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
  74.     namespace eval tcl {
  75.     proc envTraceProc {lo n1 n2 op} {
  76.         set x $::env($n2)
  77.         set ::env($lo) $x
  78.         set ::env([string toupper $lo]) $x
  79.     }
  80.     }
  81.     foreach p [array names env] {
  82.     set u [string toupper $p]
  83.     if {[string compare $u $p]} {
  84.         switch -- $u {
  85.         COMSPEC -
  86.         PATH {
  87.             if {![info exists env($u)]} {
  88.             set env($u) $env($p)
  89.             }
  90.             trace variable env($p) w [list tcl::envTraceProc $p]
  91.             trace variable env($u) w [list tcl::envTraceProc $p]
  92.         }
  93.         }
  94.     }
  95.     }
  96.     if {[info exists p]} {
  97.     unset p
  98.     }
  99.     if {[info exists u]} {
  100.     unset u
  101.     }
  102.     if {![info exists env(COMSPEC)]} {
  103.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  104.         set env(COMSPEC) cmd.exe
  105.     } else {
  106.         set env(COMSPEC) command.com
  107.     }
  108.     }
  109. }
  110.  
  111. # Setup the unknown package handler
  112.  
  113. package unknown tclPkgUnknown
  114.  
  115. # Conditionalize for presence of exec.
  116.  
  117. if {[llength [info commands exec]] == 0} {
  118.  
  119.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  120.     # platforms, safe interpreters do not have exec.
  121.  
  122.     set auto_noexec 1
  123. }
  124. set errorCode ""
  125. set errorInfo ""
  126.  
  127. # Define a log command (which can be overwitten to log errors
  128. # differently, specially when stderr is not available)
  129.  
  130. if {[llength [info commands tclLog]] == 0} {
  131.     proc tclLog {string} {
  132.     catch {puts stderr $string}
  133.     }
  134. }
  135.  
  136. # unknown --
  137. # This procedure is called when a Tcl command is invoked that doesn't
  138. # exist in the interpreter.  It takes the following steps to make the
  139. # command available:
  140. #
  141. #    1. See if the command has the form "namespace inscope ns cmd" and
  142. #       if so, concatenate its arguments onto the end and evaluate it.
  143. #    2. See if the autoload facility can locate the command in a
  144. #       Tcl script file.  If so, load it and execute it.
  145. #    3. If the command was invoked interactively at top-level:
  146. #        (a) see if the command exists as an executable UNIX program.
  147. #        If so, "exec" the command.
  148. #        (b) see if the command requests csh-like history substitution
  149. #        in one of the common forms !!, !<number>, or ^old^new.  If
  150. #        so, emulate csh's history substitution.
  151. #        (c) see if the command is a unique abbreviation for another
  152. #        command.  If so, invoke the command.
  153. #
  154. # Arguments:
  155. # args -    A list whose elements are the words of the original
  156. #        command, including the command name.
  157.  
  158. proc unknown args {
  159.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  160.     global errorCode errorInfo
  161.  
  162. puts "*** TCL UNKNOWN COMMAND: $args"
  163.  
  164.     # If the command word has the form "namespace inscope ns cmd"
  165.     # then concatenate its arguments onto the end and evaluate it.
  166.  
  167.     set cmd [lindex $args 0]
  168.     if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
  169.         set arglist [lrange $args 1 end]
  170.     set ret [catch {uplevel $cmd $arglist} result]
  171.         if {$ret == 0} {
  172.             return $result
  173.         } else {
  174.         return -code $ret -errorcode $errorCode $result
  175.         }
  176.     }
  177.  
  178.     # Save the values of errorCode and errorInfo variables, since they
  179.     # may get modified if caught errors occur below.  The variables will
  180.     # be restored just before re-executing the missing command.
  181.  
  182.     set savedErrorCode $errorCode
  183.     set savedErrorInfo $errorInfo
  184.     set name [lindex $args 0]
  185.     if {![info exists auto_noload]} {
  186.     #
  187.     # Make sure we're not trying to load the same proc twice.
  188.     #
  189.     if {[info exists unknown_pending($name)]} {
  190.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  191.     }
  192.     set unknown_pending($name) pending;
  193.     set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
  194.     unset unknown_pending($name);
  195.     if {$ret != 0} {
  196.         append errorInfo "\n    (autoloading \"$name\")"
  197.         return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
  198.     }
  199.     if {![array size unknown_pending]} {
  200.         unset unknown_pending
  201.     }
  202.     if {$msg} {
  203.         set errorCode $savedErrorCode
  204.         set errorInfo $savedErrorInfo
  205.         set code [catch {uplevel 1 $args} msg]
  206.         if {$code ==  1} {
  207.         #
  208.         # Strip the last five lines off the error stack (they're
  209.         # from the "uplevel" command).
  210.         #
  211.  
  212.         set new [split $errorInfo \n]
  213.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  214.         return -code error -errorcode $errorCode \
  215.             -errorinfo $new $msg
  216.         } else {
  217.         return -code $code $msg
  218.         }
  219.     }
  220.     }
  221.  
  222.     if {([info level] == 1) && [string equal [info script] ""] \
  223.         && [info exists tcl_interactive] && $tcl_interactive} {
  224.     if {![info exists auto_noexec]} {
  225.         set new [auto_execok $name]
  226.         if {[string compare {} $new]} {
  227.         set errorCode $savedErrorCode
  228.         set errorInfo $savedErrorInfo
  229.         set redir ""
  230.         if {[string equal [info commands console] ""]} {
  231.             set redir ">&@stdout <@stdin"
  232.         }
  233.         return [uplevel exec $redir $new [lrange $args 1 end]]
  234.         }
  235.     }
  236.     set errorCode $savedErrorCode
  237.     set errorInfo $savedErrorInfo
  238.     if {[string equal $name "!!"]} {
  239.         set newcmd [history event]
  240.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  241.         set newcmd [history event $event]
  242.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  243.         set newcmd [history event -1]
  244.         catch {regsub -all -- $old $newcmd $new newcmd}
  245.     }
  246.     if {[info exists newcmd]} {
  247.         tclLog $newcmd
  248.         history change $newcmd 0
  249.         return [uplevel $newcmd]
  250.     }
  251.  
  252.     set ret [catch {set cmds [info commands $name*]} msg]
  253.     if {[string equal $name "::"]} {
  254.         set name ""
  255.     }
  256.     if {$ret != 0} {
  257.         return -code $ret -errorcode $errorCode \
  258.         "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  259.     }
  260.     if {[llength $cmds] == 1} {
  261.         return [uplevel [lreplace $args 0 0 $cmds]]
  262.     }
  263.     if {[llength $cmds]} {
  264.         if {[string equal $name ""]} {
  265.         return -code error "empty command name \"\""
  266.         } else {
  267.         return -code error \
  268.             "ambiguous command name \"$name\": [lsort $cmds]"
  269.         }
  270.     }
  271.     }
  272.     return -code error "invalid command name \"$name\""
  273. }
  274.  
  275. # auto_load --
  276. # Checks a collection of library directories to see if a procedure
  277. # is defined in one of them.  If so, it sources the appropriate
  278. # library file to create the procedure.  Returns 1 if it successfully
  279. # loaded the procedure, 0 otherwise.
  280. #
  281. # Arguments: 
  282. # cmd -            Name of the command to find and load.
  283. # namespace (optional)  The namespace where the command is being used - must be
  284. #                       a canonical namespace as returned [namespace current]
  285. #                       for instance. If not given, namespace current is used.
  286.  
  287. proc auto_load {cmd {namespace {}}} {
  288.     global auto_index auto_oldpath auto_path
  289.  
  290.     if {[string length $namespace] == 0} {
  291.     set namespace [uplevel {namespace current}]
  292.     }
  293.     set nameList [auto_qualify $cmd $namespace]
  294.     # workaround non canonical auto_index entries that might be around
  295.     # from older auto_mkindex versions
  296.     lappend nameList $cmd
  297.     foreach name $nameList {
  298.     if {[info exists auto_index($name)]} {
  299.         uplevel #0 $auto_index($name)
  300.         return [expr {[info commands $name] != ""}]
  301.     }
  302.     }
  303.     if {![info exists auto_path]} {
  304.     return 0
  305.     }
  306.  
  307.     if {![auto_load_index]} {
  308.     return 0
  309.     }
  310.     foreach name $nameList {
  311.     if {[info exists auto_index($name)]} {
  312.         uplevel #0 $auto_index($name)
  313.         # There's a couple of ways to look for a command of a given
  314.         # name.  One is to use
  315.         #    info commands $name
  316.         # Unfortunately, if the name has glob-magic chars in it like *
  317.         # or [], it may not match.  For our purposes here, a better
  318.         # route is to use 
  319.         #    namespace which -command $name
  320.         if { ![string equal [namespace which -command $name] ""] } {
  321.         return 1
  322.         }
  323.     }
  324.     }
  325.     return 0
  326. }
  327.  
  328. # auto_load_index --
  329. # Loads the contents of tclIndex files on the auto_path directory
  330. # list.  This is usually invoked within auto_load to load the index
  331. # of available commands.  Returns 1 if the index is loaded, and 0 if
  332. # the index is already loaded and up to date.
  333. #
  334. # Arguments: 
  335. # None.
  336.  
  337. proc auto_load_index {} {
  338.     global auto_index auto_oldpath auto_path errorInfo errorCode
  339.  
  340.     if {[info exists auto_oldpath] && \
  341.         [string equal $auto_oldpath $auto_path]} {
  342.     return 0
  343.     }
  344.     set auto_oldpath $auto_path
  345.  
  346.     # Check if we are a safe interpreter. In that case, we support only
  347.     # newer format tclIndex files.
  348.  
  349.     set issafe [interp issafe]
  350.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  351.     set dir [lindex $auto_path $i]
  352.     set f ""
  353.     if {$issafe} {
  354.         catch {source [file join $dir tclIndex]}
  355.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  356.         continue
  357.     } else {
  358.         set error [catch {
  359.         set id [gets $f]
  360.         if {[string equal $id \
  361.             "# Tcl autoload index file, version 2.0"]} {
  362.             eval [read $f]
  363.         } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
  364.             while {[gets $f line] >= 0} {
  365.             if {[string equal [string index $line 0] "#"] \
  366.                 || ([llength $line] != 2)} {
  367.                 continue
  368.             }
  369.             set name [lindex $line 0]
  370.             set auto_index($name) \
  371.                 "source [file join $dir [lindex $line 1]]"
  372.             }
  373.         } else {
  374.             error "[file join $dir tclIndex] isn't a proper Tcl index file"
  375.         }
  376.         } msg]
  377.         if {[string compare $f ""]} {
  378.         close $f
  379.         }
  380.         if {$error} {
  381.         error $msg $errorInfo $errorCode
  382.         }
  383.     }
  384.     }
  385.     return 1
  386. }
  387.  
  388. # auto_qualify --
  389. #
  390. # Compute a fully qualified names list for use in the auto_index array.
  391. # For historical reasons, commands in the global namespace do not have leading
  392. # :: in the index key. The list has two elements when the command name is
  393. # relative (no leading ::) and the namespace is not the global one. Otherwise
  394. # only one name is returned (and searched in the auto_index).
  395. #
  396. # Arguments -
  397. # cmd        The command name. Can be any name accepted for command
  398. #               invocations (Like "foo::::bar").
  399. # namespace    The namespace where the command is being used - must be
  400. #               a canonical namespace as returned by [namespace current]
  401. #               for instance.
  402.  
  403. proc auto_qualify {cmd namespace} {
  404.  
  405.     # count separators and clean them up
  406.     # (making sure that foo:::::bar will be treated as foo::bar)
  407.     set n [regsub -all {::+} $cmd :: cmd]
  408.  
  409.     # Ignore namespace if the name starts with ::
  410.     # Handle special case of only leading ::
  411.  
  412.     # Before each return case we give an example of which category it is
  413.     # with the following form :
  414.     # ( inputCmd, inputNameSpace) -> output
  415.  
  416.     if {[regexp {^::(.*)$} $cmd x tail]} {
  417.     if {$n > 1} {
  418.         # ( ::foo::bar , * ) -> ::foo::bar
  419.         return [list $cmd]
  420.     } else {
  421.         # ( ::global , * ) -> global
  422.         return [list $tail]
  423.     }
  424.     }
  425.     
  426.     # Potentially returning 2 elements to try  :
  427.     # (if the current namespace is not the global one)
  428.  
  429.     if {$n == 0} {
  430.     if {[string equal $namespace ::]} {
  431.         # ( nocolons , :: ) -> nocolons
  432.         return [list $cmd]
  433.     } else {
  434.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  435.         return [list ${namespace}::$cmd $cmd]
  436.     }
  437.     } elseif {[string equal $namespace ::]} {
  438.     #  ( foo::bar , :: ) -> ::foo::bar
  439.     return [list ::$cmd]
  440.     } else {
  441.     # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  442.     return [list ${namespace}::$cmd ::$cmd]
  443.     }
  444. }
  445.  
  446. # auto_import --
  447. #
  448. # Invoked during "namespace import" to make see if the imported commands
  449. # reside in an autoloaded library.  If so, the commands are loaded so
  450. # that they will be available for the import links.  If not, then this
  451. # procedure does nothing.
  452. #
  453. # Arguments -
  454. # pattern    The pattern of commands being imported (like "foo::*")
  455. #               a canonical namespace as returned by [namespace current]
  456.  
  457. proc auto_import {pattern} {
  458.     global auto_index
  459.  
  460.     # If no namespace is specified, this will be an error case
  461.  
  462.     if {![string match *::* $pattern]} {
  463.     return
  464.     }
  465.  
  466.     set ns [uplevel namespace current]
  467.     set patternList [auto_qualify $pattern $ns]
  468.  
  469.     auto_load_index
  470.  
  471.     foreach pattern $patternList {
  472.         foreach name [array names auto_index] {
  473.             if {[string match $pattern $name] && \
  474.             [string equal "" [info commands $name]]} {
  475.                 uplevel #0 $auto_index($name)
  476.             }
  477.         }
  478.     }
  479. }
  480.  
  481. # auto_execok --
  482. #
  483. # Returns string that indicates name of program to execute if 
  484. # name corresponds to a shell builtin or an executable in the
  485. # Windows search path, or "" otherwise.  Builds an associative 
  486. # array auto_execs that caches information about previous checks, 
  487. # for speed.
  488. #
  489. # Arguments: 
  490. # name -            Name of a command.
  491.  
  492. if {[string equal windows $tcl_platform(platform)]} {
  493. # Windows version.
  494. #
  495. # Note that info executable doesn't work under Windows, so we have to
  496. # look for files with .exe, .com, or .bat extensions.  Also, the path
  497. # may be in the Path or PATH environment variables, and path
  498. # components are separated with semicolons, not colons as under Unix.
  499. #
  500. proc auto_execok name {
  501.     global auto_execs env tcl_platform
  502.  
  503.     if {[info exists auto_execs($name)]} {
  504.     return $auto_execs($name)
  505.     }
  506.     set auto_execs($name) ""
  507.  
  508.     set shellBuiltins [list cls copy date del erase dir echo mkdir \
  509.         md rename ren rmdir rd time type ver vol]
  510.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  511.     # NT includes the 'start' built-in
  512.     lappend shellBuiltins "start"
  513.     }
  514.  
  515.     if {[lsearch -exact $shellBuiltins $name] != -1} {
  516.     return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
  517.     }
  518.  
  519.     if {[llength [file split $name]] != 1} {
  520.     foreach ext {{} .com .exe .bat} {
  521.         set file ${name}${ext}
  522.         if {[file exists $file] && ![file isdirectory $file]} {
  523.         return [set auto_execs($name) [list $file]]
  524.         }
  525.     }
  526.     return ""
  527.     }
  528.  
  529.     set path "[file dirname [info nameof]];.;"
  530.     if {[info exists env(WINDIR)]} {
  531.     set windir $env(WINDIR) 
  532.     }
  533.     if {[info exists windir]} {
  534.     if {[string equal $tcl_platform(os) "Windows NT"]} {
  535.         append path "$windir/system32;"
  536.     }
  537.     append path "$windir/system;$windir;"
  538.     }
  539.  
  540.     foreach var {PATH Path path} {
  541.     if {[info exists env($var)]} {
  542.         append path ";$env($var)"
  543.     }
  544.     }
  545.  
  546.     foreach dir [split $path {;}] {
  547.     # Skip already checked directories
  548.     if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
  549.     set checked($dir) {}
  550.     foreach ext {{} .com .exe .bat} {
  551.         set file [file join $dir ${name}${ext}]
  552.         if {[file exists $file] && ![file isdirectory $file]} {
  553.         return [set auto_execs($name) [list $file]]
  554.         }
  555.     }
  556.     }
  557.     return ""
  558. }
  559.  
  560. } else {
  561. # Unix version.
  562. #
  563. proc auto_execok name {
  564.     global auto_execs env
  565.  
  566.     if {[info exists auto_execs($name)]} {
  567.     return $auto_execs($name)
  568.     }
  569.     set auto_execs($name) ""
  570.     if {[llength [file split $name]] != 1} {
  571.     if {[file executable $name] && ![file isdirectory $name]} {
  572.         set auto_execs($name) [list $name]
  573.     }
  574.     return $auto_execs($name)
  575.     }
  576.     foreach dir [split $env(PATH) :] {
  577.     if {[string equal $dir ""]} {
  578.         set dir .
  579.     }
  580.     set file [file join $dir $name]
  581.     if {[file executable $file] && ![file isdirectory $file]} {
  582.         set auto_execs($name) [list $file]
  583.         return $auto_execs($name)
  584.     }
  585.     }
  586.     return ""
  587. }
  588.  
  589. }
  590.